Grabbing SPINS gradients
## -- Attaching packages --------------------------------------- tidyverse 1.3.2 --
## v ggplot2 3.4.0 v purrr 0.3.5
## v tibble 3.1.8 v dplyr 1.0.10
## v tidyr 1.2.1 v stringr 1.4.1
## v readr 2.1.3 v forcats 0.5.2
## Warning: package 'ggplot2' was built under R version 4.1.3
## Warning: package 'tidyr' was built under R version 4.1.3
## Warning: package 'readr' was built under R version 4.1.3
## Warning: package 'purrr' was built under R version 4.1.3
## Warning: package 'dplyr' was built under R version 4.1.3
## Warning: package 'stringr' was built under R version 4.1.3
## Warning: package 'forcats' was built under R version 4.1.3
## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()
## Warning: package 'ggseg' was built under R version 4.1.3
## Warning: package 'broom' was built under R version 4.1.3
## Loading required package: prettyGraphs
## Loading required package: ExPosition
## Warning: package 'plotly' was built under R version 4.1.3
##
## Attaching package: 'plotly'
##
## The following object is masked from 'package:ggplot2':
##
## last_plot
##
## The following object is masked from 'package:stats':
##
## filter
##
## The following object is masked from 'package:graphics':
##
## layout
## Warning: package 'colorspace' was built under R version 4.1.3
##
## Attaching package: 'colorspace'
##
## The following object is masked from 'package:PTCA4CATA':
##
## lighten
## Warning: package 'RColorBrewer' was built under R version 4.1.3
## New names:
## Rows: 164640 Columns: 8
## -- Column specification
## -------------------------------------------------------- Delimiter: "," chr
## (4): ROI, Network, Subject, Site dbl (4): ...1, grad1, grad2, grad3
## i Use `spec()` to retrieve the full column specification for this data. i
## Specify the column types or set `show_col_types = FALSE` to quiet this message.
## * `` -> `...1`
## [1] "record_id" "scanner"
## [3] "diagnostic_group" "demo_sex"
## [5] "demo_age_study_entry" "scog_rmet_total"
## [7] "scog_er40_total" "scog_tasit1_total"
## [9] "scog_tasit2_sinc" "scog_tasit2_simpsar"
## [11] "scog_tasit2_parsar" "scog_tasit3_lie"
## [13] "scog_tasit3_sar" "np_domain_tscore_process_speed"
## [15] "np_domain_tscore_att_vigilance" "np_domain_tscore_work_mem"
## [17] "np_domain_tscore_verbal_learning" "np_domain_tscore_visual_learning"
## [19] "np_domain_tscore_reasoning_ps"
## New names:
## Rows: 467 Columns: 43
## -- Column specification
## -------------------------------------------------------- Delimiter: "," chr
## (4): record_id, scanner, diagnostic_group, demo_sex dbl (36): ...1,
## demo_age_study_entry, scog_rmet_total, scog_er40_total, scog... lgl (3):
## exclude_MRI, exclude_meanFD, exclude_earlyTerm
## i Use `spec()` to retrieve the full column specification for this data. i
## Specify the column types or set `show_col_types = FALSE` to quiet this message.
## * `` -> `...1`
## [1] "scog_rmet_total" "scog_er40_total"
## [3] "scog_tasit1_total" "scog_tasit2_parsar"
## [5] "scog_tasit2_simpsar" "scog_tasit2_sinc"
## [7] "scog_tasit3_lie" "scog_tasit3_sar"
## [9] "np_domain_tscore_att_vigilance" "np_domain_tscore_process_speed"
## [11] "np_domain_tscore_work_mem" "np_domain_tscore_verbal_learning"
## [13] "np_domain_tscore_visual_learning" "np_domain_tscore_reasoning_ps"
## [15] "fd_mean_rest" "bsfs_sec2_total"
## [17] "bsfs_sec3_total" "bsfs_sec4_total"
## [19] "bsfs_sec5_total" "bsfs_sec6_total"
## [21] "qls_factor_interpersonal" "qls_factor_instrumental_role"
## [23] "qls_factor_intrapsychic" "qls_factor_comm_obj_activities"
## [25] "bprs_factor_neg_symp" "bprs_factor_pos_symp"
## [27] "bprs_factor_anxiety_depression" "bprs_factor_activation"
## [29] "bprs_factor_hostility" "sans_sub_affective_flat_blunt"
## [31] "sans_sub_alogia" "sans_sub_avolition_apathy"
## [33] "sans_sub_asocial_anhedonia"
grad.sub <- spins_grads_wide$Subject[order(spins_grads_wide$Subject)]
behav.sub <- lol_spins_behav_ssd$record_id[order(lol_spins_behav_ssd$record_id)]
# behav.sub[behav.sub %in% grad.sub == FALSE]
# grad.sub[grad.sub %in% behav.sub == FALSE]
# complete.cases(spins_grads_wide)
# complete.cases(lol_spins_behav_ssd)
kept.sub <- lol_spins_behav_ssd$record_id[complete.cases(lol_spins_behav_ssd)==TRUE] # 246
## grab the matching data
behav.dat <- lol_spins_behav_ssd[kept.sub,c(6:13, 22:40)]
spins_grads_wide_org <- spins_grads_wide[,-1]
rownames(spins_grads_wide_org) <- spins_grads_wide$Subject
grad.dat <- spins_grads_wide_org[kept.sub,]
## variables to regress out
regout.dat <- var2regout_num[kept.sub,]
# lol_demo <-
# read_csv('../data/spins_lolivers_subject_info_for_grads_2022-04-21(withcomposite).csv') %>%
# filter(exclude_MRI==FALSE,
# exclude_meanFD==FALSE,
# exclude_earlyTerm==FALSE) %>% as.data.frame
# lol_demo$subject <- sub("SPN01_", "sub-", lol_demo$record_id) %>% sub("_", "", .)
# rownames(lol_demo) <- lol_demo$record_id
# lol_demo_match <- lol_demo[kept.sub,]
#
# spins_demo <- lol_demo_match %>%
# select(demo_sex, demo_age_study_entry, diagnostic_group, scog_rmet_total, scog_er40_total, #scog_mean_ea,
# scog_tasit1_total,
# scog_tasit2_total, scog_tasit3_total,np_composite_tscore, np_domain_tscore_att_vigilance,
# np_domain_tscore_process_speed, np_domain_tscore_work_mem,
# np_domain_tscore_verbal_learning, np_domain_tscore_visual_learning,
# np_domain_tscore_reasoning_ps,
# #bsfs_sec2_total, bsfs_sec3_total, bsfs_sec3_total, bsfs_sec4_total, bsfs_sec5_total, bsfs_sec6_total,
# #fd_mean_rest
# ) %>% data.frame
# colnames(spins_demo)
# rownames(spins_demo) <- lol_demo_match$subject
sub.dx <- spins_dx_org[kept.sub,]
sub.dx %>%
group_by(diagnostic_group) %>%
summarise_if(is.numeric, mean, na.rm = TRUE) %>% t
## [,1]
## diagnostic_group "case"
## demo_age_study_entry "31.28279"
sub.dx %>%
group_by(diagnostic_group) %>%
summarize_if(is.numeric, sd, na.rm = TRUE) %>% t
## [,1]
## diagnostic_group "case"
## demo_age_study_entry "9.740985"
cbind(table(sub.dx$diagnostic_group, sub.dx$demo_sex), table(sub.dx$diagnostic_group))
## female male
## case 78 166 244
table(regout.dat$demo_sex_num)
##
## 0 1
## 78 166
behav.reg <- apply(behav.dat, 2, function(x) lm(x~regout.dat$demo_sex + regout.dat$demo_age_study_entry + regout.dat$fd_mean_rest)$residual)
grad.reg <- apply(grad.dat, 2, function(x) lm(x~regout.dat$demo_sex + regout.dat$demo_age_study_entry + regout.dat$fd_mean_rest)$residual)
grad.reg2plot <- apply(grad.dat, 2, function(x){
model <- lm(x~regout.dat$demo_sex + regout.dat$demo_age_study_entry + regout.dat$fd_mean_rest)
return(model$residual + model$coefficient[1])
} )
networks <- read_delim("../networks.txt",
"\t", escape_double = FALSE, trim_ws = TRUE) %>%
select(NETWORK, NETWORKKEY, RED, GREEN, BLUE, ALPHA) %>%
distinct() %>%
add_row(NETWORK = "Subcortical", NETWORKKEY = 13, RED = 0, GREEN=0, BLUE=0, ALPHA=255) %>%
mutate(hex = rgb(RED, GREEN, BLUE, maxColorValue = 255)) %>%
arrange(NETWORKKEY)
## Rows: 718 Columns: 12
## -- Column specification --------------------------------------------------------
## Delimiter: "\t"
## chr (4): LABEL, HEMISPHERE, NETWORK, GLASSERLABELNAME
## dbl (8): INDEX, KEYVALUE, RED, GREEN, BLUE, ALPHA, NETWORKKEY, NETWORKSORTED...
##
## i Use `spec()` to retrieve the full column specification for this data.
## i Specify the column types or set `show_col_types = FALSE` to quiet this message.
networks$hex <- darken(networks$hex, 0.2)
# oi <- networks$hex
# swatchplot(
# "-40%" = lighten(oi, 0.4),
# "-20%" = lighten(oi, 0.2),
# " 0%" = oi,
# " 20%" = darken(oi, 0.2),
# " 25%" = darken(oi, 0.25),
# " 30%" = darken(oi, 0.3),
# " 35%" = darken(oi, 0.35),
# off = c(0, 0)
# )
networks
## # A tibble: 13 x 7
## NETWORK NETWORKKEY RED GREEN BLUE ALPHA hex
## <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <chr>
## 1 Visual1 1 0 0 255 255 #0707CF
## 2 Visual2 2 100 0 255 255 #5001D0
## 3 Somatomotor 3 0 255 255 255 #11C7C7
## 4 Cingulo-Opercular 4 153 0 153 255 #7D007D
## 5 Dorsal-Attention 5 0 255 0 255 #10C710
## 6 Language 6 0 155 155 255 #097A7A
## 7 Frontoparietal 7 255 255 0 255 #C7C70B
## 8 Auditory 8 250 62 251 255 #D105D2
## 9 Default 9 255 0 0 255 #CC0303
## 10 Posterior-Multimodal 10 177 89 40 255 #88492D
## 11 Ventral-Multimodal 11 255 157 0 255 #C97B05
## 12 Orbito-Affective 12 65 125 0 168 #336400
## 13 Subcortical 13 0 0 0 255 #000000
## match ROIs to networks
ROI.network.match <- cbind(spins_grads$ROI, spins_grads$Network) %>% unique
ROI.idx <- ROI.network.match[,2]
names(ROI.idx) <- ROI.network.match[,1]
### match networks with colors
net.col.idx <- networks$hex
names(net.col.idx) <- networks$NETWORK
## design matrix for subjects
diagnostic.col <- sub.dx$diagnostic_group %>% as.matrix %>% makeNominalData() %>% createColorVectorsByDesign()
rownames(diagnostic.col$gc) <- sub(".","", rownames(diagnostic.col$gc))
## design matrix for columns - behavioral
behav.dx <- matrix(nrow = ncol(behav.dat), ncol = 1, dimnames = list(colnames(behav.dat), "type")) %>% as.data.frame
behav.col <- c("scog" = "#F28E2B",
"np" = "#59A14F",
"bsfs" = "#D37295",
"bprs" = "#E15759",
"qls" = "#B07AA1",
"sans" = "#FF9888")
behav.dx$type <- sub("(^[^_]+).*", "\\1", colnames(behav.dat))
behav.dx$type.col <- recode(behav.dx$type, !!!behav.col)
## design matrix for columns - gradient
grad.dx <- matrix(nrow = ncol(grad.dat), ncol = 4, dimnames = list(colnames(grad.dat), c("gradient", "ROI", "network", "network.col"))) %>% as.data.frame
grad.dx$gradient <- sub("(^[^.]+).*", "\\1", colnames(grad.dat))
grad.dx$ROI <- sub("^[^.]+.(*)", "\\1", colnames(grad.dat))
grad.dx$network <- recode(grad.dx$ROI, !!!ROI.idx)
grad.dx$network.col <- recode(grad.dx$network, !!!net.col.idx)
## get different alpha for gradients
grad.col.idx <- c("grad1" = "grey30",
"grad2" = "grey60",
"grad3" = "grey90")
grad.dx$gradient.col <- recode(grad.dx$gradient, !!!grad.col.idx)
## for heatmap
col.heat <- colorRampPalette(c("red", "white", "blue"))(256)
pls.res <- tepPLS(behav.reg, grad.reg, DESIGN = sub.dx$diagnostic_group, make_design_nominal = TRUE, graphs = FALSE)
## [1] "DESIGN has too many columns or not enough elements. If the current DESIGN fails, a default will be created."
## [1] "DESIGN is not dummy-coded matrix. Creating default."
pls.boot <- data4PCCAR::Boot4PLSC(behav.reg, grad.reg, scale1 = "SS1", scale2 = "SS1", nIter = 1000, nf2keep = 5, eig = TRUE)
## Registered S3 method overwritten by 'data4PCCAR':
## method from
## print.str_colorsOfMusic PTCA4CATA
## Warning in matrix(svd.S$d, nJ, nf2keep, byrow = TRUE): data length [27] is not a
## sub-multiple or multiple of the number of rows [1176]
pls.boot$bootRatiosSignificant.j[abs(pls.boot$bootRatios.j) < 2.75] <- FALSE
pls.boot$bootRatiosSignificant.i[abs(pls.boot$bootRatios.i) < 2.75] <- FALSE
pls.inf <- data4PCCAR::perm4PLSC(behav.reg, grad.reg, scale1 = "SS1", scale2 = "SS1", nIter = 1000)
## swith direction for dimension 3
pls.res$TExPosition.Data$fi[,1] <- pls.res$TExPosition.Data$fi[,1]*-1
pls.res$TExPosition.Data$fj[,1] <- pls.res$TExPosition.Data$fj[,1]*-1
pls.res$TExPosition.Data$pdq$p[,1] <- pls.res$TExPosition.Data$pdq$p[,1]*-1
pls.res$TExPosition.Data$pdq$q[,1] <- pls.res$TExPosition.Data$pdq$q[,1]*-1
pls.res$TExPosition.Data$lx[,1] <- pls.res$TExPosition.Data$lx[,1]*-1
pls.res$TExPosition.Data$ly[,1] <- pls.res$TExPosition.Data$ly[,1]*-1
## Scree plot
PlotScree(pls.res$TExPosition.Data$eigs,
p.ev = pls.inf$pEigenvalues)
## Print singular values
pls.res$TExPosition.Data$pdq$Dv
## [1] 6.8621429 4.4305425 3.2700860 2.9605371 2.6581531 2.5698029 2.3139879
## [8] 2.1810770 2.0857933 1.9887070 1.8985888 1.7688406 1.7227421 1.6312282
## [15] 1.6031408 1.5867243 1.4318247 1.3843718 1.3099362 1.2558462 1.1652381
## [22] 1.1187411 1.0361131 0.9564331 0.8557764 0.8274335 0.6849617
## Print eigenvalues
pls.res$TExPosition.Data$eigs
## [1] 47.0890056 19.6297066 10.6934627 8.7647797 7.0657781 6.6038870
## [7] 5.3545399 4.7570970 4.3505337 3.9549555 3.6046394 3.1287970
## [13] 2.9678403 2.6609055 2.5700606 2.5176939 2.0501219 1.9164854
## [19] 1.7159327 1.5771497 1.3577798 1.2515817 1.0735303 0.9147642
## [25] 0.7323533 0.6846461 0.4691726
pls.res$TExPosition.Data$t
## [1] 31.5066826 13.1339986 7.1548662 5.8644078 4.7276265 4.4185807
## [7] 3.5826577 3.1829159 2.9108893 2.6462127 2.4118205 2.0934401
## [13] 1.9857460 1.7803796 1.7195964 1.6845584 1.3717117 1.2822971
## [19] 1.1481098 1.0552517 0.9084740 0.8374181 0.7182861 0.6120576
## [25] 0.4900087 0.4580884 0.3139177
## Compare the inertia to the largest possible inertia
sum(cor(behav.dat, grad.dat)^2)
## [1] 163.2374
sum(cor(behav.dat, grad.dat)^2)/(ncol(behav.dat)*ncol(grad.dat))
## [1] 0.005141012
Here, we show that the effect that PLSC decomposes is pretty small to begin with. The effect size of the correlation between the two tables is 92.40 which accounts for 0.0065 of the largest possible effect.
lxly.out[[1]]
gridExtra::grid.arrange(bar.grad1, bar.grad2, bar.grad3, ncol = 1)
PrettyBarPlot2(pls.res$TExPosition.Data$fi[,1],
threshold = 0,
color4bar = ifelse(pls.boot$bootRatiosSignificant.i[,1] == TRUE, behav.dx$type.col, "grey90"),
horizontal = FALSE, main = "Scores - behavioural")
cor.heat <- pls.res$TExPosition.Data$X %>% heatmap(col = col.heat)
## control
grad.dat.ctrl <- grad.dat[sub.dx$diagnostic_group == "control",]
behav.dat.ctrl <- behav.dat[sub.dx$diagnostic_group == "control",]
corX.ctrl <- cor(as.matrix(behav.dat.ctrl),as.matrix(grad.dat.ctrl))
heatmap(corX.ctrl[cor.heat$rowInd, cor.heat$colInd], col = col.heat, Rowv = NA, Colv = NA)
## Warning in min(x): no non-missing arguments to min; returning Inf
## Warning in max(x): no non-missing arguments to max; returning -Inf
## case
grad.dat.case <- grad.dat[sub.dx$diagnostic_group == "case",]
behav.dat.case <- behav.dat[sub.dx$diagnostic_group == "case",]
corX.case <- cor(as.matrix(behav.dat.case),as.matrix(grad.dat.case))
heatmap(corX.case[cor.heat$rowInd, cor.heat$colInd], col = col.heat, Rowv = NA, Colv = NA)
lxly.out[[2]]
gridExtra::grid.arrange(bar.grad1, bar.grad2, bar.grad3, ncol = 1)
PrettyBarPlot2(pls.res$TExPosition.Data$fi[,2],
threshold = 0, color4bar = ifelse(pls.boot$bootRatiosSignificant.i[,2] == TRUE, behav.dx$type.col, "grey90"),
horizontal = FALSE, main = "Scores - behavioural")
dim1.est <- pls.res$TExPosition.Data$pdq$Dv[1]*as.matrix(pls.res$TExPosition.Data$pdq$p[,1], ncol = 1) %*% t(as.matrix(pls.res$TExPosition.Data$pdq$q[,1], ncol = 1))
cor.heat.res1 <- (pls.res$TExPosition.Data$X - dim1.est) %>% heatmap(col = col.heat)
lxly.out[[3]]
gridExtra::grid.arrange(bar.grad1, bar.grad2, bar.grad3, ncol = 1)
PrettyBarPlot2(pls.res$TExPosition.Data$fi[,3],
threshold = 0, color4bar = ifelse(pls.boot$bootRatiosSignificant.i[,3] == TRUE, behav.dx$type.col, "grey90"),
horizontal = FALSE, main = "Scores - behavioural")
dim2.est <- (as.matrix(pls.res$TExPosition.Data$pdq$p[,1:2]) %*% pls.res$TExPosition.Data$pdq$Dd[1:2,1:2] %*% t(as.matrix(pls.res$TExPosition.Data$pdq$q[,1:2])))
cor.heat.res2 <- heatmap(pls.res$TExPosition.Data$X - dim2.est, col = col.heat)
lxly.out[[4]]
gridExtra::grid.arrange(bar.grad1, bar.grad2, bar.grad3, ncol = 1)
PrettyBarPlot2(pls.res$TExPosition.Data$fi[,4],
threshold = 0,
color4bar = ifelse(pls.boot$bootRatiosSignificant.i[,4] == TRUE, behav.dx$type.col, "grey90"),
horizontal = FALSE, main = "Scores - behavioural")
dim3.est <- (as.matrix(pls.res$TExPosition.Data$pdq$p[,1:3]) %*% pls.res$TExPosition.Data$pdq$Dd[1:3,1:3] %*% t(as.matrix(pls.res$TExPosition.Data$pdq$q[,1:3])))
cor.heat.res3 <- heatmap(pls.res$TExPosition.Data$X - dim3.est, col = col.heat)
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'